perm filename EAID.1[MAC,LSP]10 blob
sn#659294 filedate 1982-05-09 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00012 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 MacLisp Aids for E
C00016 00003 E Manipulation Routines
C00023 00004 A mapping function for E entities
C00026 00005 Sends a page of stuff, 200 liness at a time
C00027 00006 Stuff to lookup a word in UNABRD.DIC Takes a word in the attach
C00039 00007 Routines to exchange 2 pages.
C00042 00008 A routine to clean up a file.
C00048 00009 Not equals
C00050 00010 Hack to Double Column
C00052 00011 For Finding Strings
C00053 00012 For Responding to MAIL.
C00058 ENDMK
C⊗;
;;; MacLisp Aids for E
(declare (special ?e:id *e:a1 *e:a2 *e:b1 *e:b2 -em:sfa-
-em:mail-input-buffer-dry-handler-)
(setq defmacro-for-compiling ())
(muzzled t)
(*lexpr %match)
(*expr em:warn read-filename em:tyi-line em:readonly-var em:raw-ecommands
%instantiate em:tyi-message em:readonly-vars em:ecommands))
(defun e:goto (page line)
(em:ecommands (append (e:make-e-control-number page)
'(α P)
(e:make-e-control-number line)
'(α L))))
(defun e:make-e-control-number (n)
(cond ((zerop n)(list 'α 0))
(t
(let ((sign (cond ((lessp n 0) '-))))
(setq n (abs n))
(do ((i n (quotient i 10.))
(ans ()))
((zerop i) (cond (sign (push sign ans)(push 'α ans)))
ans)
(push (remainder i 10.) ans)
(push 'α ans))))))
(defun e:balance ()
(let ((alist (em:readonly-vars '(line lines page pages))))
(let ((line (cdr (assq 'line alist)))
(lines (cdr (assq 'lines alist)))
(pages (cdr (assq 'pages alist)))
(cpage (cdr (assq 'page alist)))
(cline (cdr (assq 'line alist)))
(page (cdr (assq 'page alist))))
(em:ecommands '(α - α V))
(e:balance2 line lines page pages)
(em:ecommands (append (e:make-e-control-number cpage)
'(α p)
(e:make-e-control-number cline)
'(⊗ ↔)
'(α V)))
'done)))
(defun e:balance2 (line lines page pages)
(do ((page page (1+ page)) (cline ()))
((< pages page))
(do ((line line (1+ line)))
((< lines line)
(or (= pages page)
(em:ecommands '(α p)))
(setq line 1
lines
(cdr (assq 'lines (em:readonly-vars '(lines))))))
(em:ecommands '(α =))
(setq cline (em:tyi-message))
(cond ((%match
'(*e:a1 ?e:id ($r ? e:lbp)
*e:b1)
(reverse cline))
(setq *e:a1 (reverse *e:a1)
*e:b1 (reverse *e:b1))
(cond ((%match
`(,@*e:b1
? ? *e:b2 ,?e:id ($r ? e:rbp) *e:a2)
cline)
(let ((balance (e:count-parens
*e:b2)))
(cond ((> balance 0)
(em:ecommands '(α K ⊗ ↔ α ⊗ ↔))
(em:raw-ecommands
(append *e:b1 *e:b2
(e:n-parens balance)
*e:a2))
(em:ecommands '(⊗ B α // α ⊗ ↔))
(setq line (1- line)))
((< balance 0)
(em:ecommands '(α K ⊗ ↔ α ⊗ ↔))
(em:raw-ecommands
(append
*e:b1
(cdr (e:flush-n-parens
*e:b2
(minus balance))) *e:a2))
(em:ecommands '(⊗ B α // α ⊗ ↔))
(setq line (1- line)))
(t
(em:ecommands '(α K ⊗ ↔ α ⊗ ↔))
(em:raw-ecommands
(append *e:b1 *e:b2 *e:a2))
(em:ecommands '(⊗ B α // α ⊗ ↔))
(setq line (1- line))))))
(t (em:ecommands '(α K ⊗ ↔ α ⊗ ↔))
(em:raw-ecommands (append *e:b1 *e:a1))
(em:ecommands '(⊗ B α // ⊗ ↔))
(cond ((%match '(* ($r ? e:lbp) *) *e:a1)
(em:ecommands '(⊗ B))
(let ((?e:id ())(*e:b1 ())(*e:a1()))
(e:balance2 line lines page pages))
(e:goto page line)
(em:ecommands '(α =))
(setq cline (em:tyi-message))
(%match `(,@*e:b1 *e:a1) cline)))
(e:balance1 ?e:id (e:count-parens *e:a1)
(1+ line) lines page pages)
(e:goto page line)
(setq line (1- line)))))
(t (em:ecommands '(⊗ ↔)))))))
(defmacro e:backup ()
`(cond ((= line 1)
(cond ((= page 1)
(print 'Not-balanced)
(*throw 'out ()))
(t (setq page (1- page))
(em:ecommands '(α - α P))
(setq lines (cdr (assq 'lines
(em:readonly-vars '(lines)))))
(setq line lines)
(em:ecommands (append
(e:make-e-control-number lines)
'(α L))))))
(t (setq line (1- line))
(em:ecommands '(⊗ B)))))
(defun e:balance1 (id n line lines page pages)
(let ((cline ()))
(*catch 'done
(do ((page page (1+ page)))
((< pages page)
(print 'Not-balanced))
(do ((line line (1+ line)))
((< lines line)
(or (= page pages)
(em:ecommands '(α p)))
(setq line 1
lines
(cdr (assq 'lines (em:readonly-vars '(lines))))))
(em:ecommands '(α =))
(setq cline (em:tyi-message))
(cond ((%match '(* ($r ? e:lbp) *) cline)
(let ((?e:id ())(*e:b1 ())(*e:a1 ())(*e:b2 ())(*e:a2 ()))
(e:balance2 line lines page pages))
(e:goto page line)))
(cond ((%match `(*e:b1 ,id ($r ? e:rbp) *e:a1)
cline)
(let ((balance (+ n (e:count-parens
*e:b1))))
(cond ((> balance 0)
(em:ecommands '(α K ⊗ ↔ α ⊗ ↔))
(em:raw-ecommands
(append *e:b1
(e:n-parens balance)
*e:a1))
(em:ecommands '(⊗ B α // ⊗ ↔)))
((< balance 0)
(prog ()
again
(em:ecommands '(α K ⊗ ↔ α ⊗ ↔))
(let ((n
(e:flush-n-parens *e:b1
(minus balance))))
(em:raw-ecommands
(append
(cdr n)
*e:a1))
(em:ecommands '(⊗ B α // ⊗ ↔))
(cond ((= (car n) 0) (return t))
(t
(e:backup)
(em:ecommands '(α =))
(setq cline (em:tyi-message))
(setq *e:b1 cline
*e:a1 ())
(go again))))))
(t
(em:ecommands '(α K ⊗ ↔ α ⊗ ↔))
(em:raw-ecommands
(append *e:b1 *e:a1))
(em:ecommands '(⊗ B α // ⊗ ↔)))))
(*throw 'done t))
(t (em:ecommands '(α // ⊗ ↔))
(setq n (+ n (e:count-parens cline))))))))))
(defun e:count-parens (l)
(do ((l l (cdr l))
(n 0))
((null l) n)
(cond ((e:lpp (car l))
(setq n (1+ n)))
((e:rpp (car l))
(setq n (1- n)))
((e:scp (car l)) ;semi-colon
(return n)))))
(defun e:n-parens (n)
(do ((n n (1- n))
(ans ()))
((= n 0) ans)
(push #o51 ans)))
(defun e:flush-n-parens (l n)
(do ((l l (cdr l))
(a ()))
((or (null l)
(e:scp (car l)))
(do ((a a (cdr a))
(quit ())
(ans ())
(n n))
((or quit (= n 0)) `(,n . ,(append (reverse a) ans l)))
(cond ((e:rpp (car a))
(setq n (1- n)))
((null a)
(setq quit t))
(t (push (car a) ans)))))
(push (car l) a)))
(defun e:scp (n)(= n #o73))
(defun e:lpp (n)(= n #o50))
(defun e:rpp (n)(= n #o51))
(defun e:lbp (n)(= n #o133))
(defun e:rbp (n)(= n #o135))
(declare (special e:line e:lines e:page e:pages))
(defun e:send-next-line ()
(let ((-em:mail-input-buffer-dry-handler- ()))
(cond ((= e:lines e:line)
(cond ((= e:page e:pages)
(break |No right paren found| t))
(t (em:ecommands
'(α p))
(setq e:line 1
e:page (1+ e:page)
e:lines
(cdr (assq 'lines
(em:readonly-vars '(lines)))))
(em:ecommands '(α =)))))
(t (em:ecommands '(⊗ ↔ α =))
(setq e:line (1+ e:line))))))
(defun e:send-this-line ()
(let ((-em:mail-input-buffer-dry-handler- ()))
(cond ((< e:lines e:line)
(cond ((= e:page e:pages)
(break |No right paren found| t))
(t (em:ecommands
'(α p))
(setq e:line 1
e:page (1+ e:page)
e:lines
(cdr (assq 'lines
(em:readonly-vars '(lines)))))
(em:ecommands '(α =)))))
(t (em:ecommands '(α = ⊗ ↔))
(setq e:line (1+ e:line))))))
;;; SEXP on next line
(defun e:eval-next-sexp ()
(em:ecommands '(α β - α β V))
(e:eval-next-sexp1)
(em:ecommands '(α β V)))
(defun e:eval-next-sexp1 ()
(let ((alist (em:readonly-vars '(line lines page pages))))
(setq e:line (cdr (assq 'line alist))
e:lines (cdr (assq 'lines alist))
e:page (cdr (assq 'page alist))
e:pages (cdr (assq 'pages alist))))
(let ((-em:mail-input-buffer-dry-handler- 'e:send-next-line))
(print (eval (read)))))
;;; SEXP on this line
(defun e:eval-this-sexp ()
(em:ecommands '(α β - α β V))
(e:eval-this-sexp1)
(em:ecommands '(α β V)))
(defun e:eval-this-sexp1 ()
(let ((alist (em:readonly-vars '(line lines page pages))))
(setq e:line (cdr (assq 'line alist))
e:lines (cdr (assq 'lines alist))
e:page (cdr (assq 'page alist))
e:pages (cdr (assq 'pages alist))))
(cond ((< e:lines e:line)(setq e:line (1- e:line))
(em:ecommands '(⊗ ↑))))
(let ((-em:mail-input-buffer-dry-handler- 'e:send-this-line))
(print (eval (read)))))
;;; E Manipulation Routines
;;; These are to help the user edit his MacLisp file.
;;; This routine sends the current sexp no matter where you
;;; are as long as you are `inside' of it
(defun e:send-this-defun ()
(em:ecommands '(α β - α β V))
(e:find-defun-backwards);find the previous defun, defmacro...
(e:eval-this-sexp1) ;evaluate it
(em:ecommands '(α β V)))
(defun e:find-enclosing-defun ()
(em:ecommands '(α - α v))
(e:find-defun-backwards)
(em:ecommands '(α - α v))
'done)
(defun e:find-defun-backwards ()
(let ((alist (em:readonly-vars '(line lines page pages))))
(setq e:line (cdr (assq 'line alist))
e:lines (cdr (assq 'lines alist))
e:page (cdr (assq 'page alist))
e:pages (cdr (assq 'pages alist)))
(cond ((< e:lines e:line)(setq e:line (1- e:line))
(em:ecommands '(⊗ ↑))))
(*catch 'e:find-defun-backwards
(do ((e:page e:page (1- e:page)))
((< e:page 1) (break |Defun not found| t))
(do ((e:line e:line (1- e:line)))
((< e:line 1))
(em:ecommands '(α =))
(cond ((e:defun-on-this-linep (em:tyi-message))
(*throw 'e:find-defun-backwards t)))
(em:ecommands '(⊗ b)))
(em:ecommands '(α - α p α ∞ ⊗ ↔ ⊗ b))
(setq e:lines (cdr (assq 'lines (em:readonly-vars '(lines)))))
(setq e:line e:lines)))))
;;; For now it looks for:
;;; (defun
;;; (defmacro
;;; (macro
;;; (match-macro
;;; (macrodef
(defun e:defun-on-this-linep (text)
(or
(%match '(* #o50 ($ir * e:spacep)
($r ? e:dp)
($r ? e:ep)
($r ? e:fp)
($r ? e:up)
($r ? e:np) ($r ? e:spacep) *) text)
(%match '(* #o50 ($ir * e:spacep)
($r ? e:dp)
($r ? e:ep)
($r ? e:fp)
($r ? e:mp)
($r ? e:ap)
($r ? e:cp)
($r ? e:rp)
($r ? e:op) ($r ? e:spacep) *) text)
(%match '(* #o50 ($ir * e:spacep)
($r ? e:mp)
($r ? e:ap)
($r ? e:tp)
($r ? e:cp)
($r ? e:hp)
($r ? e:-p)
($r ? e:mp)
($r ? e:ap)
($r ? e:cp)
($r ? e:rp)
($r ? e:op) ($r ? e:spacep) *) text)
(%match '(* #o50 ($ir * e:spacep)
($r ? e:mp)
($r ? e:ap)
($r ? e:cp)
($r ? e:rp)
($r ? e:op)
($r ? e:dp)
($r ? e:ep)
($r ? e:fp) ($r ? e:spacep) *) text)
(%match '(* #o50 ($ir * e:spacep)
($r ? e:mp)
($r ? e:ap)
($r ? e:cp)
($r ? e:rp)
($r ? e:op) ($r ? e:spacep) *) text)))
(defun e:white-spacep (n) (or (= n #o40)
(= n #o11)))
(defun e:not-white-spacep (n) (not (or (= n #o40)
(= n #o11))))
(defun e:dp (n) (or (= n #o104)
(= n #o144)))
(defun e:ep (n) (or (= n #o105)
(= n #o145)))
(defun e:fp (n) (or (= n #o106)
(= n #o146)))
(defun e:up (n) (or (= n #o125)
(= n #o165)))
(defun e:np (n) (or (= n #o116)
(= n #o156)))
(defun e:mp (n) (or (= n #o115)
(= n #o155)))
(defun e:ap (n) (or (= n #o101)
(= n #o141)))
(defun e:cp (n) (or (= n #o103)
(= n #o143)))
(defun e:rp (n) (or (= n #o122)
(= n #o162)))
(defun e:op (n) (or (= n #o117)
(= n #o157)))
(defun e:tp (n) (or (= n #o124)
(= n #o164)))
(defun e:hp (n) (or (= n #o110)
(= n #o150)))
(defun e:-p (n) (= n #o55))
(defun e:semip (n)(= n #o73))
(defun e:spacep (n)(= n #o40))
(defun e:letterp (n)
(or (and (< #o100 n)
(< n #o133))
(and (< #o140 n)
(< n #o173))))
(defun e:digitp (n)(and (< #o57 n)(< n #o72)))
(defun e:digit-letterp (n)
(or (e:letterp n)
(e:digitp n)))
(defun e:not-digit-letterp (n)
(not (or (e:letterp n)
(e:digitp n))))
(defun e:tabp (n) (= n #o11))
(defun e:langlep (n)(= n #o74))
(defun e:ranglep (n)(= n #o76))
(defun e:@p (n)(= n #o100))
;;; A mapping function for E entities
;;; NIL result for fun means stay on current line, number means go up or down
;;; that amount. T means next line.
(defun e:page-map (fun)
(em:ecommands '(α - α V α L))
(do ((line (em:readonly-var 'line)) (result))
((< (em:readonly-var 'lines) line) (em:ecommands '(α V)) 'done)
(em:ecommands '(α =))
(setq result (funcall fun (em:tyi-message)))
(cond ((numberp result)
(em:ecommands
(append
(e:make-e-control-number result) '(⊗ ↔)))
(setq line (+ line result)))
(result (setq line (1+ line))
(em:ecommands '(⊗ ↔))))))
(defun e:set-current-line (cline)
(em:raw-ecommands (append '(#o2 #o113 #o26 #o27)
cline '(#o26 #o102))))
(declare (special e:productions))
;;; Does not need the crlf at the end of the line in the production
(defun e:crlf () '(#o15 #o12))
(setq e:productions
`(((*st ($ir *sp e:white-spacep) ($r ? e:digit-letterp)
($ir *junk e:digit-letterp) ,@(e:crlf))
(*st))))
(defun e:ponder-line (line)
(do ((l e:productions (cdr l)))
((null l) t)
(cond ((%match (caar l)
line)
(em:raw-ecommands (append '(#o2 #o113 #o26 #o27)
(%instantiate (cadar l))
'(#o2 #o26 #o27)))))))
(defun e:transform-page () (e:page-map #'e:ponder-line))
;;; Sends a page of stuff, 200 liness at a time
(comment
(defun e:send-page ()
(let ((lines (cdr (assq 'lines (em:readonly-vars '(lines))))))
(let ((n (quotient lines 200.)))
(em:ecommands '(α - α V α L))
(cond ((not (= 0 (remainder lines 200.)))
(setq n (1+ n))))
(do ((i n (1- i)))
((= i 0) (em:ecommands '(α V)) 'done)
(em:ecommands '(α 2 α 0 α 0 α = α 0 α = 0 ⊗ ↔))
(read)
(em:ecommands '(α 2 α 0 α 0 ⊗ ↔))))))
)
;;; Stuff to lookup a word in UNABRD.DIC Takes a word in the attach
;;; buffer and say αz F
(declare (special e:dir-h))
(array e:unabrd t 235.)
(do ((l
'(A accordantly actinomeric advisal agitation alem altaite ampelotherapy ancillary anodendron anticritique Aonian apron argel Ascetta
atechnical autocephality azotate balloonful basisphenoid beerhouse beprose Bidens bitterwood board Bothrodendron breediness Buchnera
by calotermitid capripede caryatic cecidiologist Cestida cheese choanosome churchman clart coagitator cointense commot confinedness
contorsive corke counterbuff crateman cruroinguinal curvy dacryocystosyringotomy debatingly degradement denudate detergence dicetyl
diplacusis disharmonism Ditremidae dosimetrist dualin ebulus elderbrotherhood emetomorphine enforcer Epanorthidae equivocal
ethnogeographer exceptionality extending fanfare ferreting firelock floriculture foregleam frangula funambulator gamont Gemmingia
gigglingly glycogenize gracilis grooveless gymnurine hangar heaviness hemoconcentration heteronomy histotrophy hoof huntilite
hyostylic hypotrachelium illocality impregnant incubous inferringly insense interjaculate intrarelation irreportable Jacamerops
jonque Kawchodinne klipdas lackadaisical larrigan lehr lienopancreatic lithopedium lougheen Maba malapropoism marcello maxillojugal
mellifluent Mesosauria microbrachius minding misspend monkism moringaceous multifold myitis nasicorn nephology nineteenfold
nonconformance nonliquidation nonsympathizer numerator octan ombrophyte opsonic orthotypous outjest overdaintiness overrealism oxyphile
palinody papion parling pauperess penetrator perigone pet Philodinidae phrenomagnetism piglet Placoidei pleurogenous poison
polysyllabically postexilian preallotment predwell preprudent primevity progressionism protectible pseudocultural pucka Pygopodes
quatrayle radiolucency reaccord recondense refreshen remitment reservedness retrovert ribbed Romescot rundale salicylic Sarothra
chematic scranny Seder seminase sergeantship Sharia shrinal sinewiness slangish snakeproof solvend sparver spinsterism spumification
statesmanlike stimy strident subcrepitant substandardize sulphureously superpraise swan synergize tamandu tawdered tenantless
etrapody thermoneutrality thurify titleboard torulose transformism trichloride tritonymphal Tuesday type unadventurously unblossomed
uncompliableness undenominationalize undescript unerected unfrounced uniformal unleafed unobediently unpretendingness unreticent
unskirted untantalized unwearying urethralgia vanadous verdureless violent vulvovaginitis waxing whirroo witloof xanthophyllous
zac)
(cdr l))
(i 0 (+ i 1)))
((null l)(setq e:dir-h (- i 1)))
(store (e:unabrd i) `(,(car l) . ,(+ i 2))))
(defmacro dword (n) `(car (e:unabrd ,n)))
(defmacro dpage (n) `(cdr (e:unabrd ,n)))
(defun e:word-lookup (word)
(cond ((> (em:readonly-var 'attsiz)
0)
(em:ecommands '(α β K))))
(em:ecommands (append '(α ε u n a b r d // d //)
(let ((base 10.)( *nopoint t))
(explode (e:bin-search word)) )
'(p ⊗ ↔)))
(em:ecommands (append '(α β F) (explode word) '(⊗ ↔)))
'done)
(defun e:word-lookup-here (word)
(cond ((> (em:readonly-var 'attsiz)
0)
(em:ecommands '(α β K))))
(em:ecommands (append (e:make-e-control-number
(e:bin-search word))
'(α p ⊗ ↔)))
(em:ecommands (append '(α β F) (explode word) '(⊗ ↔)))
'done)
(defun e:Bin-search (word)
(let ((low 0)
(high e:dir-h))
(do ((mid (// (+ low high) 2)
(// (+ low high) 2)))
((not (< low high))
(dpage low))
(cond ((eq (dword mid)
word)
(return (dpage mid)))
((alphalessp (dword mid) word)
(cond ((eq (dword (+ mid 1)) word)
(return (dpage (+ mid 1))))
((alphalessp word (dword (+ mid 1)))
(return (dpage mid)))
(t (setq low (+ mid 1)))))
(t (setq high (- mid 1)))))))
;;; Routines to exchange 2 pages.
(defun ↔ fexpr (x)
(let ((n (car x))
(m (cadr x)))
(cond ((null m)(setq m n)(setq n ())))
(cond
((and (null n)(null m)))
(t
(do ((x (cdr n) (cdr x))
(y (cdr m) (cdr y))
(max (or (car n) (car m)))(min (or (car n)(car m))))
((and (null x)(null y))
(setq n (do ((i max (- i 1))
(l () `(,i . ,l)))
((< i min) l))))
(setq min (min min (or (car x) min)(car y)))
(setq max (max max (or (car x) max)(car y))))
(em:ecommands '(α - α v))
(cond ((numberp n)(e:exchange n m))
(t (let ((map (mapcar #'(lambda (x) `(,x . ,x)) n)))
(do ((n n (cdr n))
(m m (cdr m)) (pos1)(pos2))
((or (null n)(null m)) 'done)
(setq pos1 (assoc (car m) map))
(setq pos2 (do ((map map (cdr map))
(x (car n)))
((null map) ())
(cond ((= x (cdr (car map)))
(return (car map))))))
(cond ((= (car n) (cdr pos1)))
(t
(e:exchange (car n)(cdr pos1))
(rplaca pos1 (prog1 (car pos2)
(rplaca pos2 (car pos1))))))))))
(em:ecommands '(α v))))))
(defun e:exchange (n m)
(let ((ln 0)
(lm 0)
(current-page (em:readonly-var `page)))
(e:goto n 1)
(setq ln (em:readonly-var 'lines))
(em:ecommands (append
(e:make-e-control-number ln)
'(α A)))
(e:goto m 1)
(setq lm (em:readonly-var 'lines))
(em:ecommands (append '(α e)
(e:make-e-control-number ln)
'(⊗ ↔)
(e:make-e-control-number lm)
'(α a)))
(e:goto n 1)
(em:ecommands (append
'(α e)
(e:make-e-control-number current-page)
'(α p)))
'done))
;;; A routine to clean up a file.
;;; The following commands on the first line of a page dispose
;;; of that page:
;;; ↓ deletes page
;;; →<filename> sends that page to the end of the file indicated
(declare (special e:activity))
(defun e:dispose-file ()
(em:ecommands '(α - α V))
(let ((vars (em:readonly-vars '(page pages))))
(do ((pages (- (+ 1 (cdr (assq 'pages vars)))
(cdr (assq 'page vars)))
(- pages 1))
(e:activity ())
(winners '(())))
((= pages 0) (em:ecommands '(α 1 α p α v))
(cond ((null e:activity)
(terpri)
(princ '|No changes to file.|)
(terpri)))
'done)
(e:dispose-page (not (= pages 1)) winners))))
(defun e:dispose-page (flag winners) ;go to next page flag
(cond ((not (= (em:readonly-var 'lines) 0))
(let ((line (em:tyi-line)))
(do ((l line (cdr l)))
((not (member (car l)
'(#o15 #o12 #o40 #o21)))
(setq line l)))
(cond ((= (car line) 1) ;↓
(setq e:activity t)
(e:delete-page))
((= (car line) 25.) ;→<filename>
(setq e:activity t)
(em:ecommands '(α k → α D α ⊗ ↔ α =))
(let ((file (car (read-filename ()))))
(cond ((or (member file (cdr winners))
(cond ((probef file)
(nconc winners (ncons file))
t)))
(em:ecommands '(α β D))
(cond ((= (em:readonly-var 'lines) 0)
(em:ecommands '(α ∂ α β D)))
(t (e:move-page-to-file file)) ))
(t (em:ecommands '(β → α ⊗ ↔))
(em:warn
(implode (append
(explode file)
'(| | |n| |o| |t| | | |f| |o| |u| |n| |d|))))
(cond (flag (em:ecommands '(α p))))))))
(flag (em:ecommands '(α p))))))
(flag (em:ecommands '(α p)))))
(defun e:delete-page ()
(em:ecommands (append (e:make-e-control-number (em:readonly-var 'lines))
'(α β D α ∂ α β D))))
;;; file looks like ((dsk (aid rpg)) foo bar)
(defmacro file-filename (file) `(cadr ,file))
(defmacro file-extension (file) `(caddr ,file))
(defmacro file-project (file) `(car (cadr (car ,file))))
(defmacro file-programmer (file) `(cadr (cadr (car ,file))))
(defmacro flush-slashes (l)
`(mapcan (function (lambda (x) (cond ((eq x '//) ())
(t (ncons x)))))
,l))
(defun e:move-page-to-file (file)
(em:ecommands (append (e:make-e-control-number (em:readonly-var 'lines))
'(α A α ε)
(flush-slashes (explode (file-filename file)))
(cond ((not (eq (file-extension file)
'←←←))
(append '(/.)
(flush-slashes (explode (file-extension file))))))
'(/[)
(flush-slashes (explode (file-project file)))
'(/,)
(flush-slashes (explode (file-programmer file)))
'(/] // e ⊗ ↔ α X M A R K ⊗ ↔ α H α ∂ α β D))))
(defun e:switch-file (file)
(em:ecommands (append '(α ε)
(flush-slashes (explode (file-filename file)))
(cond ((not (eq (file-extension file)
'←←←))
(append '(/.)
(flush-slashes (explode (file-extension file))))))
'(/[)
(flush-slashes (explode (file-project file)))
'(/,)
(flush-slashes (explode (file-programmer file)))
'(/] // e ⊗ ↔))))
;;; Not equals
(defun e:not-equals (x)
(cond
((numberp x)
(e:not-equals-number1 x))
((atom x)
(do ((v (e:not-equals-atom1 x)
(e:not-equals-atom1 x)))
(v v)))
((hunkp x) (let ((l (hunksize x))
(h ()))
(setq h (makhunk l))
(do ((i 0 (1+ i)))
((= i l) h)
(rplacx i h (e:not-equals (cxr i x))))))
(t (mapcar #'e:not-equals x)))))
(defun e:not-equals-atom1 (x)
(let ((n (random (cadr (arraydims obarray))))
(flag ())
(i 0))
(*catch 'out
(mapatoms
#'(lambda (y)
(cond ((not flag)
(cond ((= i n)
(setq flag t))
(t (setq i (1+ i)))))
((not (eq x y))
(*throw 'out y))))))))
(defun e:not-equals-number1 (x)
(do ((i (random 1000.)(random 1000.)))
((not (= x i)) i)))
;;; Hack to Double Column
(defun e:double ()
(let ((n (em:readonly-var 'attsiz)))
(let ((hn (// n 2))
(oddp ()))
(cond ((= n (* hn 2)))
(t (setq oddp t)))
(em:ecommands (append
'(α - α V α E)
(cond (oddp
(e:make-e-control-number (1+ hn)))
(t (e:make-e-control-number hn)))
'(⊗ ↔)
(e:make-e-control-number hn)
'(α A)))
(cond (oddp
(em:ecommands '(⊗ ↑))))
(do ((i hn (1- i)))
((= i 0)
(do ((i hn (1- i)))
((= i 0)
(em:ecommands '(α V))
'done)
(em:ecommands '(α ⊗ = α d β ⊗ = ⊗ ↔))))
(em:ecommands '(α - α a ⊗ ↑))))))
;;; For Finding Strings
(declare (special e:search-string))
(setq e:search-string ())
(defun e:set-string (string)
(setq e:search-string string)
t)
(defun e:find-string ()
(em:ecommands (append
'(α F)
(explode e:search-string)
'(⊗ ↔)))
t)
(defun e:xfind-string ()
(em:ecommands (append
'(α x F | |)
(explode e:search-string)
'(⊗ ↔)))
t)
(defun e:report-string () e:search-string)
;;; For Responding to MAIL.
(declare (special e:mail-headers *site *name *junk *subject))
(setq e:mail-headers
'((* ($r ? e:langlep) ($ir *name e:not-white-spacep)
($ir * e:white-spacep)
($r ? e:ap) ($r ? e:tp) ($ir * e:white-spacep)
($ir *site e:not-white-spacep)($r ? e:ranglep)
*subject)
(* ($r ? e:tabp) ($ir *name e:not-white-spacep)
($ir * e:white-spacep)
($r ? e:ap) ($r ? e:tp) ($r ? e:white-spacep)
($ir * e:white-spacep)
($ir *site e:not-white-spacep)
($ir * e:white-spacep)
#o50 * #o51
($ir * e:white-spacep)
($r ? e:rp) ($r ? e:ep) #o72
($r ? e:white-spacep) *subject)
(* ($r ? e:tabp) ($ir *name e:not-white-spacep)
($ir * e:white-spacep)
($r ? e:ap) ($r ? e:tp) ($r ? e:white-spacep)
($ir * e:white-spacep)
($ir *site e:not-white-spacep)
($r ? e:white-spacep) *subject)
(* ($r ? e:tabp) ($ir *name e:not-white-spacep) ($r ? e:@p)
($ir *site e:not-white-spacep) ($r ? e:white-spacep) *subject)
(* #o11 #o61 #o60 #o60 ($ir * e:white-spacep) #o72
($ir * e:white-spacep) ($ir *name e:not-white-spacep)
($r ? e:white-spacep) *subject)
(* ($r ? e:tabp) ($ir *name e:not-white-spacep)
($r ? e:white-spacep) *subject)
))
;;; Returns entire page to sender
(defun e:respond-mail ()
(em:ecommands '(α - α v))
(let ((attsiz (em:readonly-var 'attsiz))
(linenum ()))
(cond ((= attsiz 0))
(t (em:ecommands '(α E))
(setq linenum (em:readonly-var 'line))))
(em:ecommands '(α l))
(let ((line (em:tyi-line)))
(do ((l e:mail-headers (cdr l))
(*name ())(*site ())(*subject ()))
((null l) (em:ecommands '(α v))
'Huh?)
(cond ((%match (car l)
line)
(cond ((not (= attsiz 0))
(em:ecommands
(append
(e:make-e-control-number (1- linenum))
'(⊗ ↔)
(e:make-e-control-number attsiz)
'(α a)))))
(em:raw-ecommands
(append
'(#o2 #o130 #o115 #o101 #o111 #o114 #o57 #o123
#o125 #o40)
*name
(cond (*site '(#o100)))
(cond (*site))
'(#o40)
(e:condition-subject *subject)
'(#o26 #o27)))
(cond ((not (= attsiz 0))
(em:ecommands '(α E))))
(em:ecommands '(α V))
(return 'done)))))))
(defun e:condition-subject (l)
(do ((x l (cdr x)))
((e:not-white-spacep (car x)))
(setq l (cdr l)))
(%match `(*junk ,@(e:crlf)) l)
(setq *junk (reverse *junk))
(do ((x *junk (cdr x)))
((e:not-white-spacep (car x))
(reverse *junk))
(setq *junk (cdr *junk))))